;;;;;
;;;;; PARSERS
;;;;; A parser takes a list (i.e. an object or array of objects) and
;;;;; returns the expression object it represents.
;;;;;
;;;;; There is one global parser that contains the global environment inside
;;;;; of it.  We handle binding of local variables by making a new parser
;;;;; object that quick checks to see if the expression is one of the local
;;;;; variables and otherwise just calls its "parent" parser.
;;;;;
;;;;; Special forms and macros are handled by binding a variable with the
;;;;; same name as the special form (e.g. if) to a parser object that knows
;;;;; how to parse the macro or special form.
;;;;;


;;;;
;;;; Forward references
;;;; Ignore this; it's just here because the macro processor is stupid.
;;;;
(define-imported-class expression object)
(define-imported-class parser object)
(define-imported-class local-environment-parser object)
(define-imported-class namespace parser)
(define-imported-class with-star-parser parser)
(define-imported-class (fluid (object default-value)) procedure
  (define fluid-value "Value" (public) object))
(define-imported-class (hashtable "System.Collections.Hashtable") object
  (define (remove (object key)) (public) void))
(define-imported-class (idictionaryenumerator
			"System.Collections.IDictionaryEnumerator")
  object
  (define current "Current" (public) object)
  (define (move-next) (public virtual) boolean)
  (define (reset) (public virtual) void)
  (define key "Key" (public) object)
  (define idictionaryenumerator-value "Value" (public) object)
  (define entry "Entry" (public) object))
(define-imported-class (icollection "System.Collections.ICollection") object
  (define icollection-count "Count" (public) integer))
(define-imported-class (idictionary "System.Collections.IDictionary") object
  (define keys "Keys" (public) icollection)
  (define (dictionary-add "Add" (object key) (object value)) (public) void)
  (define (get-enumerator) (public virtual) idictionaryenumerator))

(define-imported-class (begin-expression ((array expression) body)) expression)
(define-imported-class definition expression
  (define dvar "variable" (public) global-variable)
  (define dval "value" (public) expression))
(define-imported-class definition-parser object)

(define-imported-class (empty-body-error) parse-error)
(define-imported-class (unnecessary-code-error (expression exp)
					       (ilist parent))
  parse-error)

(define-imported-class (malformed-definition-error (string msg) (object o))
  parse-error)
(define-imported-class (malformed-definition-variable-error (string msg)
							    (object o)
							    (object var))
  malformed-definition-error)

(%import-object 'default-namespace-kluge "Namespace.CurrentNamespace"
		(type-expression-value 'namespace))
(%import-object 'root-namespace-kluge "Namespace.RootNamespace"
		(type-expression-value 'namespace))

(define-imported-class void-thunk object)
(define-imported-class (invalid-type-expression-error (object o)) parse-error)

(import-methods (contains? "Contains" (proc (object object) boolean)))
(import-methods (insert "Insert" (proc ((type-expression-value 'array-list)
					integer object) void)))
(import-static (call-current-namespace-changed "Namespace.CurrentNamespaceChanged"
					       (proc () void))
	       (substitute-newlines "Utilities.SubstituteNewLines"
				    (proc (string) string))
	       (parse-procedure-type-expression "ProcedureType.ParseProcedureTypeExpression"
						(proc (object) clr-type)))

(define-imported-class (list-of (clr-type element-type)) clr-type)

;;;;
;;;; REAL CODE START HERE
;;;;

(define-module (lisp parser)
  ;;;
  ;;; PARSER
  ;;; This is the base class for parsers and also the type of the default parser.
  ;;;
  (define-class (parser) (object "IArglist" "IDocumentable")
    ;; Check if a list has the right length for the expression it is
    (define (check-length (ilist list)
			  (integer min-length)
			  (integer max-length))
      (public static void)
      (let ((len (count list)))
	(when (< len min-length)
	  (throw (parse-error "Too few arguments to expression"
			       list)))
	(when (and (> max-length 0)
		   (> len max-length))
	  (throw (parse-error "Too many arguments to expression"
			       list)))))

    ;; Parse an s-expression in the current default namespace.
    (define (simple-parse tuple) "Parse" (public static expression)
      (parse default-namespace-kluge
	     tuple
	     default-namespace-kluge))

    ;; A simple kluge for parsing s-expressions that are supposed to denote
    ;; types.  They must be variable references that are type objects and
    ;; marked as constants.  Returns the actual type object.
    ;;
    ;; N.B.: this only checks the current default namespace (i.e. the global
    ;; environment that's currently in effect), so you can't lexically bind
    ;; a type and refer to the lexical name.  Sorry.
    (define (parse-type-expression sexp) (public static clr-type)
      (cond ((or (is? sexp symbol)
		 (and (is? sexp ilist)
		      (not (= (count (cast ilist sexp)) 0))
		      (eq? (vector-ref (cast ilist sexp) 0)
			   s-member)))
	     (let ((v (as (simple-parse sexp) global-variable)))
	       (when (null? v)
		 (throw (invalid-type-expression-error sexp)))
	       (let ((t (value v)))
		 (when (or (null? t)
			   (not (is? t clr-type)))
		   (throw (invalid-type-expression-error sexp)))
		 (cast clr-type t))))
	    ((is? sexp ilist)
	     (let ((lst (cast ilist sexp)))
	       (if (and (= (count lst) 2)
			(eq? (vector-ref lst 0)
			     s-list-of))
		   (new list-of
			(parse-type-expression (vector-ref lst 1)))
		   (let ((arrow (index-of lst lambda-arrow)))
		     (if (>= arrow 0)
			 (parse-procedure-type-expression (cast ilist sexp))
			 (throw (invalid-type-expression-error sexp)))))))
	    (else
	     (throw (invalid-type-expression-error sexp)))))

    ;; Check if op-exp denotes a Parser (i.e. special form or macro).
    (define (check-parser (expression op-exp))
      (private static parser)
      (when (null? op-exp)
	(return null))
      (let ((g (as op-exp global-variable))
	    (c (as op-exp constant)))
	(if (null? g)
	    (if (null? c)
		null
		(as (cvalue c) parser))
	    (as (value g) parser))))

    ;; Declare that NEW-LIST should inherit the source-code location of OLD-LIST
    (define (declare-source-alias new-list old-list) (public static object)
      (let ((r current-reader-kluge))
	(unless (null? r)
	  (declare-source r new-list old-list))
	new-list))

    (define (definition? sexp (parser p)) "IsDefinition" (public static boolean)
      (when (null? sexp)
	(return false))
      (let ((l (as sexp ilist)))
	(when (or (null? l)
		  (< (count l) 2)
		  (not (is? (vector-ref l 0)
			    symbol)))
	  (return false))
	(let ((op (parse p (vector-ref l 0) p)))
	  (and (is? op global-variable)
	       (is? (value (cast global-variable op))
		    definition-parser)))))

    (define (definition-variable-name (ilist def)) (private static symbol)
      (let ((varexp (vector-ref def 1)))
	(cond ((null? varexp)
	       (throw (malformed-definition-variable-error "Variable name can't be null" def null)))
	      ((is? varexp symbol)
	       (cast symbol varexp))
	      ((is? varexp ilist)
	       (let ((l (cast ilist varexp)))
		 (when (< (count def) 3)
		   (throw (malformed-definition-error "Definition must contain at least a variable name and a value"
						      def)))
		 (let ((name (vector-ref l 0)))
		   (cond ((null? name)
			  (throw (malformed-definition-variable-error "Variable name can't be null" def null)))
			 ((is? name symbol)
			  (cast symbol name))
			 (else
			  (throw (malformed-definition-variable-error "Defining something that isn't a variable?"
								      def
								      name)))))))
	      (else
	       (throw (malformed-definition-variable-error "Defining something that isn't a variable?"
							   def varexp))))))

    (define (definition-value-expression (ilist def)) (private static object)
      (let ((varexp (vector-ref def 1)))
	(cond ((null? varexp)
	       (throw (malformed-definition-variable-error "Variable name can't be null" def null)))
	      ((is? varexp symbol)
	       (when (> (count def)
			4)
		 (throw (malformed-definition-error "Too many subexpressions in definition" def)))
	       (if (= (count def) 3)
		   (vector-ref def 2)
		   (vector-ref def 3)))
	      (else
	       (let ((l (cast ilist varexp)))
		 (let ((args (rest (cast ilist varexp)))
		       (body (rest (rest def))))
		   (let ((fn (new-array object (+ (count args)
						  (count body)
						  1))))
		     (copy-into args fn 0)
		     (copy-into body fn (+ (count args) 1))
		     (declare-source-alias fn def)
		     (set (vector-ref fn (count args)) lambda-arrow)
		     fn)))))))

    (define (parse-body (ilist arr) (integer start) (parser p)
			(boolean allow-internal-defines?))
      (public static expression)
      (let ((non-definition start))
	(when allow-internal-defines?
	  (while (and (< non-definition (count arr))
		      (definition? (vector-ref arr non-definition) p))
	    (set non-definition (+ non-definition 1))))
	(let ((dcount (- non-definition start))
	      (body-len (- (count arr)
			   non-definition)))
	  (if (= dcount 0)
	      ;; No internal defines
	      (cond ((= body-len 1)
		     (parse p (vector-ref arr start) p))
		    ((= body-len 0)
		     (throw (empty-body-error)))
		    (else
		     (let ((b (new-array expression body-len)))
		       (dotimes (i body-len)
			 (set (vector-ref b i)
			      (parse p
				     (vector-ref arr (+ start i))
				     p)))
		       (dotimes (j (- body-len 1))
			 (when (or (is? (vector-ref b j)
					variable)
				   (is? (vector-ref b j)
					constant))
			   (throw (unnecessary-code-error (vector-ref b j)
							  arr))))
		       (let ((exp (begin-expression b)))
			 (set (source-location exp)
			      (list-position (vector-ref arr start)))
			 exp))))
	      ;; It has internal defines
	      (let ((result (new-array object (+ 1 ;with*
						 (* dcount 3)
						 body-len)))
		    (position 1))
		(set (vector-ref result 0)
		     (new with-star-parser))
		(dotimes (di dcount)
		  (set (vector-ref result position)
		       (definition-variable-name (vector-ref arr
							     (+ start di))))
		  (set (vector-ref result (+ position 1))
		       s-equal)
		  (set (vector-ref result (+ position 2))
		       (definition-value-expression (vector-ref arr
								(+ start di))))
		  (set position (+ position 3)))
		(dotimes (k body-len)
		  (set (vector-ref result position)
		       (vector-ref arr (+ non-definition k)))
		  (set position (+ position 1)))
		(parse p result p))))))

    ;; DEFAULT PARSER
    ;; All other parsers fall through to here.
    ;; 
    ;; Handles the following cases:
    ;; - Expressions that are already parsed (i.e. it's not an s-expression,
    ;;   it's already a Meta.Expression object)
    ;; - Calls to special forms (if the subparser returns a parser object for
    ;;   the value of the operator position of the s-expression)
    ;; - Applications (it it's a list but not a special form)
    ;; - Constants (all other cases)
    ;;
    ;; It does not handle variable references.  Variable references are parsed
    ;; by environments (local-environment-parsers or namespaces), which then
    ;; call *this* (their base method), if the s-expression isn't a symbol.
    (define (parse p (object list) (parser subparser))
      (public virtual expression)
      (typecheck list
		 (expression
		  ;; It's already parsed into an expression, so just pass it on.
		  ;; This happens when a macro wants to insert something that
		  ;; it doesn't want messed with.  It provides a sort of
		  ;; poor-man's syntactic closure.
		  (lambda (e) e))
		 (ilist
		  ;; It's a compound s-expression
		  (lambda (arr)
		    (when (= (count arr) 0)
		      (throw (parse-error "Bad compound expression: no subexpressions" arr)))
		    (let ((arrow (index-of arr lambda-arrow))
			  (result null)
			  (op (vector-ref arr 0))
			  (position (list-position arr))
			  (the-eval-stack current-thread-eval-stack))
		      (push the-eval-stack parse-procedure (new-array object 1
								      arr))
		      (cond ((and (>= arrow 0)
				  (not (eq? op s-quote)))  ; kluge
			     ;; It's an infix -> (i.e. a lambda)
			     (set result
				  (parse (cast parser
					       (value (parse p lambda-arrow p)))
					 list
					 subparser)))
			    ((and (> (count arr) 1)
				  (not (eq? op s-quote))
				  (eq? (vector-ref arr 1)
				       assignment-arrow))
			     ;; It's an infix <- (i.e. an assignment)
			     (set result
				  (parse (cast parser
					       (value (parse p assignment-arrow p)))
					 list
					 subparser)))
;			    ((and (> (count arr) 1)
;				  (not (eq? (vector-ref arr 0)
;					    s-quote))
;				  (eq? (vector-ref arr 1)
;				       assignment-arrow))
;			     (parse (cast parser
;					  (value (parse p assignment-arrow p)))
;				    (new-array object 3
;					       assignment-arrow
;					       (vector-ref arr 0)
;					       (vector-ref arr 2))
;				    p))
			    (else
			     ;; Check if it's an application
			     (let ((op-exp (parse subparser op subparser))
				   (form-parser (check-parser op-exp)))
			       (cond ((eq? form-parser null)
				      ;; Yes, it's an application
				      (cond ((eq? (vector-ref arr (- (count arr) 1))
						  s-ellipsis)
					     ;; This is an application that ends in an ellipsis, so it's an implicit apply
					     (let ((replacement (new-array object (count arr))))
					       (copy-sublist arr 0
							     (cast ilist replacement) 1
							     (- (count arr) 1))
					       (set (vector-ref replacement 0)
						    (parse root-namespace-kluge
							   s-apply
							   root-namespace-kluge))
					       (set result
						    (parse this
							   (cast ilist replacement)
							   subparser))))
					    (else
					     ;; Normal application
					     (let ((args (drop arr 1)))
					       (set result
						    (make-application op-exp
								      (map-array (arg args expression)
										 (parse subparser
											arg
											subparser))))))))
				     (else
				      ;; Special form or macro call
				      (set result
					   (parse form-parser list subparser)))))))
		      ;; Set the source-location field of the expression object
		      ;; to the source location of the originating s-expression
		      (when (>= position 0)
			(set (source-location result)
			     position))
		      (pop the-eval-stack)
		      result)))
		 (else
		  ;; It's not a compound s-expression or a pre-parsed expression
		  ;; so it must be a constant.
		  (constant list))))
    ;; This is just a placeholder so that the default parser has a bogus
    ;; procedure object to push on the stack when it makes a frame for itself
    ;; (this is only important for debugging purposes).
    (define parse-procedure (static private procedure)
      (new method-wrapper "parse" null))


    ;;; Slots applicable only to special forms and macros (not the default
    ;;; parser or local-environment-parsers).

    ;; How the pretty-printer should indent things.
    (define (indent-style p) (public virtual property object)
      null)

    (define (documentation p)
      (return ""))

    ;; Arglist
    (define (arglist p)
      (cast (array object) null)))

  ;;;
  ;;; LOCAL-ENVIRONMENT-PARSER
  ;;; Handles name resolution for variables in local environments.
  ;;; Like a namespace, in that it only parses names and calls parent to
  ;;; handle parsing of all other expressions.  However, it is not a subclass
  ;;; of namespace because you can't create bindings in it on the fly, import
  ;;; other namespaces, etc.
  ;;;  
  (define-class (local-environment-parser self-name self-variable
					  names variables
					  parent nesting-level)
    parser
    (define self-name (private symbol) null)
    (define self-variable (private local-variable) null)
    (define names (private (array object)) null)
    (define variables (private (array local-variable)) null)
    (define parent (private parser) null)
    (define nesting-level (public integer) 0)

    (define (parse me list subparser)
      (let ((s-list (as list symbol)))
	(cond ((not (eq? s-list null))
	       (if (eq? s-list (self-name me))
		   (self-variable me)
		   (let ((index (index-of (names me) s-list)))
		     (if (>= index 0)
			 (vector-ref variables index)
			 (parse (parent me) list subparser)))))
	      (else
	       (parse (parent me) list subparser))))))

 (define-class (parser-wrapper the-parser) call-interface-procedure
    (define the-parser "parser" (public parser) null)
    (define (call1 wrapper list)
      (let ((p (the-parser wrapper)))
	(parse p list p))))

   ;;;
   ;;; REWRITER
   ;;; These are user-level parsers implemented as Meta procedures.
   ;;;
  (define-class (rewriter rewrite-procedure) parser
    (define (rewriter-name p) "Name" (public property object)
      (procedure-name (rewrite-procedure p)))
    (define rewrite-procedure (public procedure) null)
    (define (parse p list subparser)
      (call2 (rewrite-procedure p)
	     list
	     (parser-wrapper subparser))))

  ;;;
  ;;; MACROS
  ;;; Like rewriters but returns a list that then gets parsed.
  ;;;
  (define-class (macro rewrite-procedure) (parser "IArglist" "IDocumentable")
    (define (macro-name p) "Name" (public property object)
      (procedure-name (rewrite-procedure p)))
    (define rewrite-procedure (public procedure) null)
    (define (arglist p)
      (arglist-kluge (cast i-arglist (rewrite-procedure p))))
    (define (documentation p)
      (documentation-kluge (cast i-documentable (rewrite-procedure p))))
    (define x-indent-style "indentStyle" (public object) null)
    (define (indent-style p) (public override property object)
      (x-indent-style p))
    (define (parse p list subparser)
      (parse subparser
	     (traced-apply-no-stack (rewrite-procedure p)
			   (as-object-array (rest (cast ilist list))))
	     subparser))))